Programmers Heaven 2/Programmers Heaven 2.iso/files/windows/ocx/midipk.exe/MFEDIT.FRM

Visual Basic Form | 1996-08-30 | 38.3 KB | 1,167 lines

VERSION 4.00
Begin VB.Form Form1
   Appearance      =   0  'Flat
   AutoRedraw      =   -1  'True
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "MFEDIT"
   ClientHeight    =   5430
   ClientLeft      =   2100
   ClientTop       =   2190
   ClientWidth     =   9240
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   1
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   6120
   Icon            =   "MFEDIT.frx":0000
   Left            =   2040
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   5430
   ScaleWidth      =   9240
   Top             =   1560
   Width           =   9360
   Begin VB.Frame Frame3
      Caption         =   "Playback Rate"
      Height          =   855
      Left            =   7080
      TabIndex        =   12
      Top             =   2220
      Width           =   2055
      Begin HslideLib.HSlider PlaybackRateSlider
         Height          =   375
         Left            =   240
         TabIndex        =   41
         Top             =   360
         Width           =   1575
         _version        =   65537
         _extentx        =   2778
         _extenty        =   661
         _stockprops     =   65
         bevelinner      =   0
         bevelouter      =   0
         bevelwidth      =   1
         borderwidth     =   2
         gap             =   3
         largechange     =   10
         thumbheight     =   360
         thumbstyle      =   2
         thumbwidth      =   120
         tickcolor       =   0
         tickcount       =   11
         ticklength      =   4
         tickmarks       =   3
         tickwidth       =   1
         trackbevel      =   0
         trackwidth      =   0
         value           =   0
         max             =   500
         min             =   -500
      End
   End
   Begin VB.Frame Frame5
      Caption         =   "Playback Controls"
      Height          =   2115
      Left            =   7080
      TabIndex        =   30
      Top             =   3180
      Width           =   2055
      Begin VB.CommandButton CmdStop
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Stop"
         Height          =   435
         Left            =   120
         TabIndex        =   31
         Top             =   1500
         Width           =   1815
      End
      Begin VB.CommandButton CmdRecord
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Record"
         Height          =   435
         Left            =   120
         TabIndex        =   32
         Top             =   900
         Width           =   1815
      End
      Begin VB.CommandButton CmdPlay
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Play"
         Height          =   435
         Left            =   120
         TabIndex        =   33
         Top             =   300
         Width           =   1815
      End
   End
   Begin VB.Frame Frame4
      Caption         =   "MIDI File Settings"
      Height          =   2175
      Left            =   7080
      TabIndex        =   36
      Top             =   -30
      Width           =   2055
      Begin VB.Label LabelTicks
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BackColor       =   &H00000000&
         Caption         =   "Tick"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   1
            weight          =   400
            size            =   9.75
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H0000FF00&
         Height          =   255
         Left            =   240
         TabIndex        =   37
         Top             =   1800
         Width           =   1635
      End
      Begin VB.Label LabelTimeSignature
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BackColor       =   &H00000000&
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Time Signature"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   1
            weight          =   400
            size            =   9.75
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H0000FF00&
         Height          =   315
         Left            =   240
         TabIndex        =   34
         Top             =   540
         Width           =   1635
      End
      Begin VB.Label LabelTempo
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BackColor       =   &H00000000&
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Tempo"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   1
            weight          =   400
            size            =   9.75
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H0000FF00&
         Height          =   315
         Left            =   240
         TabIndex        =   35
         Top             =   1140
         Width           =   1635
      End
      Begin VB.Label Label7
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         Caption         =   "Time Signature"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   1
            weight          =   400
            size            =   9.75
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H80000008&
         Height          =   255
         Left            =   120
         TabIndex        =   40
         Top             =   300
         Width           =   1815
      End
      Begin VB.Label Label8
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         Caption         =   "Tempo"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   1
            weight          =   400
            size            =   9.75
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H80000008&
         Height          =   255
         Left            =   120
         TabIndex        =   39
         Top             =   900
         Width           =   1815
      End
      Begin VB.Label Label9
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         Caption         =   "Ticks Per Quarter Note"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   1
            weight          =   400
            size            =   8.25
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H80000008&
         Height          =   255
         Left            =   120
         TabIndex        =   38
         Top             =   1560
         Width           =   1815
      End
   End
   Begin VB.PictureBox Picture1
      BorderStyle     =   0  'None
      Height          =   435
      Left            =   60
      ScaleHeight     =   435
      ScaleWidth      =   6915
      TabIndex        =   19
      Top             =   60
      Width           =   6915
      Begin VB.CheckBox MidiThruCheck
         Caption         =   "Midi Thru"
         Height          =   255
         Left            =   2820
         TabIndex        =   22
         Top             =   60
         Value           =   1  'Checked
         Width           =   1155
      End
      Begin VB.ComboBox InputDevCombo
         Appearance      =   0  'Flat
         Height          =   300
         Left            =   60
         Style           =   2  'Dropdown List
         TabIndex        =   18
         Top             =   60
         Width           =   2535
      End
      Begin VB.ComboBox OutputDevCombo
         Appearance      =   0  'Flat
         Height          =   300
         Left            =   4140
         Style           =   2  'Dropdown List
         TabIndex        =   20
         Top             =   60
         Width           =   2535
      End
   End
   Begin VB.Frame Frame2
      Caption         =   "Tracks"
      Height          =   4755
      Left            =   60
      TabIndex        =   13
      Top             =   540
      Width           =   3195
      Begin VB.ListBox TrackList
         Appearance      =   0  'Flat
         Height          =   2955
         Left            =   120
         TabIndex        =   17
         Top             =   300
         Width           =   2955
      End
      Begin VB.CommandButton CmdInsertTrack
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Insert New Track"
         Height          =   435
         Left            =   120
         TabIndex        =   16
         Top             =   4260
         Width           =   2955
      End
      Begin VB.CommandButton CmdDeleteTrack
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Delete Current Track"
         Height          =   435
         Left            =   120
         TabIndex        =   15
         Top             =   3780
         Width           =   2955
      End
      Begin VB.CommandButton CmdQueueTrack
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Queue Current Track"
         Height          =   435
         Left            =   120
         TabIndex        =   14
         Top             =   3300
         Width           =   2955
      End
   End
   Begin VB.Frame Frame1
      Caption         =   "Messages"
      Height          =   4755
      Left            =   3330
      TabIndex        =   4
      Top             =   540
      Width           =   3675
      Begin VB.PictureBox Picture2
         BorderStyle     =   0  'None
         Height          =   1875
         Left            =   120
         ScaleHeight     =   1875
         ScaleWidth      =   3495
         TabIndex        =   23
         Top             =   2820
         Width           =   3495
         Begin VB.TextBox MessageEdit
            Appearance      =   0  'Flat
            Height          =   285
            Left            =   1020
            TabIndex        =   29
            Top             =   60
            Width           =   555
         End
         Begin VB.TextBox Data1Edit
            Appearance      =   0  'Flat
            Height          =   285
            Left            =   1020
            TabIndex        =   28
            Top             =   420
            Width           =   555
         End
         Begin VB.TextBox Data2Edit
            Appearance      =   0  'Flat
            Height          =   285
            Left            =   2700
            TabIndex        =   27
            Top             =   420
            Width           =   555
         End
         Begin VB.TextBox TimeEdit
            Appearance      =   0  'Flat
            Height          =   285
            Left            =   1020
            TabIndex        =   26
            Top             =   780
            Width           =   1035
         End
         Begin VB.TextBox BufferEdit
            Appearance      =   0  'Flat
            Height          =   285
            Left            =   1020
            TabIndex        =   25
            Top             =   1140
            Width           =   2415
         End
         Begin VB.TextBox MsgTextEdit
            Appearance      =   0  'Flat
            Height          =   285
            Left            =   1020
            TabIndex        =   24
            Top             =   1500
            Width           =   2415
         End
         Begin VB.Label Label1
            Alignment       =   1  'Right Justify
            Caption         =   "Message:"
            Height          =   255
            Left            =   60
            TabIndex        =   6
            Top             =   60
            Width           =   855
         End
         Begin VB.Label Label2
            Alignment       =   1  'Right Justify
            Caption         =   "Data1:"
            Height          =   255
            Left            =   60
            TabIndex        =   7
            Top             =   420
            Width           =   855
         End
         Begin VB.Label Label3
            Alignment       =   1  'Right Justify
            Caption         =   "Data2:"
            Height          =   255
            Left            =   1740
            TabIndex        =   8
            Top             =   420
            Width           =   855
         End
         Begin VB.Label Label4
            Alignment       =   1  'Right Justify
            Caption         =   "Buffer:"
            Height          =   255
            Left            =   60
            TabIndex        =   9
            Top             =   1140
            Width           =   855
         End
         Begin VB.Label Label5
            Alignment       =   1  'Right Justify
            Caption         =   "Time:"
            Height          =   255
            Left            =   60
            TabIndex        =   10
            Top             =   780
            Width           =   855
         End
         Begin VB.Label Label6
            Caption         =   "MsgText:"
            Height          =   255
            Left            =   120
            TabIndex        =   11
            Top             =   1500
            Width           =   795
         End
      End
      Begin VB.CheckBox InsertRecordingCheck
         Caption         =   "Insert Recording"
         Height          =   255
         Left            =   1620
         TabIndex        =   21
         Top             =   2520
         Width           =   1755
      End
      Begin VB.CommandButton CmdDeleteMessage
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Delete"
         Height          =   315
         Left            =   2700
         TabIndex        =   0
         Top             =   2160
         Width           =   855
      End
      Begin VB.CommandButton CmdInsertMessage
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Insert"
         Height          =   315
         Left            =   1440
         TabIndex        =   1
         Top             =   2160
         Width           =   855
      End
      Begin VB.CommandButton CmdModifyMessage
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         Caption         =   "Modify"
         Height          =   315
         Left            =   120
         TabIndex        =   2
         Top             =   2160
         Width           =   855
      End
      Begin VB.CheckBox HexCheck
         Caption         =   "Hexadecimal"
         Height          =   255
         Left            =   180
         TabIndex        =   3
         Top             =   2520
         Value           =   1  'Checked
         Width           =   1455
      End
      Begin VB.ListBox MessageList
         Appearance      =   0  'Flat
         Height          =   1785
         Left            =   120
         TabIndex        =   5
         Top             =   300
         Width           =   3435
      End
   End
   Begin MidifileLib.Midifile Midifile1
      Left            =   4440
      Top             =   5400
      _version        =   65537
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      filename        =   ""
   End
   Begin MidiioLib.MIDIOutput MIDIOutput1
      Left            =   3840
      Top             =   5400
      _version        =   65537
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      deviceid        =   0
      volumeleft      =   -1
      volumeright     =   -1
   End
   Begin MidiioLib.MIDIInput MIDIInput1
      Left            =   3240
      Top             =   5400
      _version        =   65537
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
   End
   Begin MSComDlg.CommonDialog CMDialog1
      Left            =   2700
      Top             =   5340
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
      defaultext      =   "mid"
      filter          =   "Open MIDI File"
      filterindex     =   290
      fontsize        =   2.98738e-38
   End
   Begin VB.Menu FileMenu
      Caption         =   "&File"
      Begin VB.Menu FileNew
         Caption         =   "&New"
      End
      Begin VB.Menu FileOpen
         Caption         =   "&Open..."
      End
      Begin VB.Menu FileSave
         Caption         =   "&Save"
      End
      Begin VB.Menu FileSaveAs
         Caption         =   "Save &As..."
      End
      Begin VB.Menu FileSep1
         Caption         =   "-"
      End
      Begin VB.Menu FileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim msPerTick(50) As Long
Dim ticksPerMs(50) As Long
Dim fModified As Integer
Dim fGotFirst As Integer
Dim fRecording As Integer
Dim CurrentTime As Double
Dim PreviousTime As Double
Dim InCurrentTime As Double
Dim InPreviousTime As Double
Dim TempoTime(50) As Long
Dim TempoSetting(50) As Long
Dim TotalTempoChanges As Integer
Dim Lyric(1000) As String
Private Sub CloseInputDevice()
    '
    ' Close if open
    '
    If MIDIInput1.State >= MIDISTATE_OPEN Then
        MIDIInput1.Action = MIDIIN_CLOSE
    End If
End Sub
Private Sub CloseOutputDevice()
    If MIDIOutput1.State >= MIDISTATE_OPEN Then
        MIDIOutput1.Action = MIDIOUT_CLOSE
    End If
End Sub
Private Sub CmdDeleteMessage_Click()
    MIDIFile1.Action = MIDIFILE_DELETE_MESSAGE
    fModified = True
    DisplayTrack (TrackList.ListIndex + 1)
End Sub
Private Sub CmdDeleteTrack_Click()
    Dim t As Integer
    If TrackList.ListIndex = -1 Then
      MsgBox "No track slected."
      Exit Sub
      End If
    MIDIFile1.TrackNumber = TrackList.ListIndex + 1
    MIDIFile1.Action = MIDIFILE_DELETE_TRACK
    fModified = True
    t = TrackList.ListIndex
    DisplayTrackList
    If (t > TrackList.ListCount - 1) Then
        t = t - 1
    End If
    TrackList.ListIndex = t
End Sub
Private Sub CmdInsertMessage_Click()
    MIDIFile1.Message = FetchNumber(CStr(MessageEdit.Text))
    MIDIFile1.Data1 = FetchNumber(CStr(Data1Edit.Text))
    MIDIFile1.Data2 = FetchNumber(CStr(Data2Edit.Text))
    MIDIFile1.Time = FetchNumber(CStr(TimeEdit.Text))
    MIDIFile1.Action = MIDIFILE_INSERT_MESSAGE
    fModified = True
    DisplayTrack (TrackList.ListIndex + 1)
End Sub
Private Sub CmdInsertTrack_Click()
    Dim t As Integer
    If TrackList.ListIndex = -1 Then
        MIDIFile1.TrackNumber = 1
        MIDIFile1.Action = MIDIFILE_INSERT_TRACK
        fModified = True
        t = TrackList.ListIndex
        DisplayTrackList
        TrackList.ListIndex = t + 1
    Else
        MIDIFile1.TrackNumber = TrackList.ListIndex + 1
        MIDIFile1.Action = MIDIFILE_INSERT_TRACK
        fModified = True
        t = TrackList.ListIndex
        DisplayTrackList
        TrackList.ListIndex = t + 1
        End If
End Sub
Private Sub CmdModifyMessage_Click()
    Dim m As Integer
    MIDIFile1.Message = FetchNumber(CStr(MessageEdit.Text))
    MIDIFile1.Data1 = FetchNumber(CStr(Data1Edit.Text))
    MIDIFile1.Data2 = FetchNumber(CStr(Data2Edit.Text))
    MIDIFile1.Time = FetchNumber(CStr(TimeEdit.Text))
    MIDIFile1.Buffer = BufferEdit.Text
    MIDIFile1.MsgText = MsgTextEdit.Text
    MIDIFile1.Action = MIDIFILE_MODIFY_MESSAGE
    m = MIDIFile1.MessageNumber
    fModified = True
    DisplayTrack (TrackList.ListIndex + 1)
    If (m > MIDIFile1.MessageCount) Then
        m = m - 1
    End If
    MessageList.ListIndex = m
End Sub
Private Sub CmdPlay_Click()
    StartPlay
End Sub
Private Sub CmdQueueTrack_Click()
    If TrackList.ListIndex = -1 Then
      MsgBox "No track selected."
      Exit Sub
      End If

    CmdQueueTrack.Enabled = False
    CmdDeleteTrack.Enabled = False
    CmdInsertTrack.Enabled = False
    Screen.MousePointer = 11
    QueueTrack (TrackList.ListIndex + 1)
    On Error Resume Next
    TrackList.ListIndex = TrackList.ListIndex + 1
    On Error GoTo 0
    Screen.MousePointer = 0
    CmdQueueTrack.Enabled = True
    CmdDeleteTrack.Enabled = True
    CmdInsertTrack.Enabled = True
End Sub
Private Sub CmdRecord_Click()
    InsertRecordingCheck.Value = 1
    StartPlay
    StartRecording
End Sub
Private Sub CmdStop_Click()
    StopPlay
    StopRecording
End Sub
Private Sub DisplayTrack(t As Integer)
    Dim i As Integer
    Screen.MousePointer = 11
    MessageList.Clear
    MIDIFile1.TrackNumber = t
    For i = 1 To MIDIFile1.MessageCount
        If (i > 500) Then
            Exit For
            End If
        MIDIFile1.MessageNumber = i
        '
        'Meta Event
        '
        If (MIDIFile1.Message = META) Then
            Select Case MIDIFile1.Data1
                Case META_SEQUENCE_NUMBER
                    MessageList.AddItem "Sequence number " & Hex$(MIDIFile1.Data2) & " : " & MIDIFile1.MsgText
                Case META_TEXT
                    MessageList.AddItem "Text " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case META_COPYRIGHT
                    MessageList.AddItem "Copyright " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case META_NAME
                    MessageList.AddItem "Track Name " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case META_INST_NAME
                    MessageList.AddItem "Instrument Name " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case META_LYRIC
                    MessageList.AddItem "Lyric " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case META_MARKER
                    MessageList.AddItem "Marker " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case META_CUE_POINT
                    MessageList.AddItem "Cue point " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case META_TEMPO
                    MessageList.AddItem Str(MIDIFile1.Time) & " Tempo " & Int(60000000 / MIDIFile1.Tempo)
                Case META_TIME_SIG
                    MessageList.AddItem Str(MIDIFile1.Time) & " Time Signature " & MIDIFile1.Numerator & "/" & (2 ^ MIDIFile1.Denominator)
                Case Else
                    MessageList.AddItem "Sysex " & Hex$(MIDIFile1.Data1)
                End Select
        Else
            Select Case (MIDIFile1.Message And &HF0)
                Case NOTE_OFF
                    MessageList.AddItem "Note Off " & Hex$(MIDIFile1.Message)
                Case NOTE_ON
                    MessageList.AddItem "Note On " & Hex$(MIDIFile1.Message)
                Case POLY_KEY_PRESS
                    MessageList.AddItem "Poly Key Press " & Hex$(MIDIFile1.Message)
                Case CONTROLLER_CHANGE
                    MessageList.AddItem "Controller Change " & Hex$(MIDIFile1.Message)
                Case PROGRAM_CHANGE
                    MessageList.AddItem "Program Change " & Hex$(MIDIFile1.Message)
                Case CHANNEL_PRESSURE
                    MessageList.AddItem "Channel Pressure " & Hex$(MIDIFile1.Message)
                Case PITCH_BEND
                    MessageList.AddItem "Pitch Bend " & Hex$(MIDIFile1.Message)
                Case Else
                    MessageList.AddItem Hex$(MIDIFile1.Message)
                End Select
            End If
        Next i
    Screen.MousePointer = 0
    End Sub
Private Sub DisplayTrackList()
    Dim m As Integer
    Dim t As Integer
    TrackList.Clear
    For t = 1 To MIDIFile1.NumberOfTracks
        TrackList.AddItem GetTrackName(t)
    Next
    GetTempoChanges
    GetTimeSignature
End Sub
Private Function FetchNumber(s As String) As Integer
    If (HexCheck.Value) Then
        FetchNumber = Val("&H" & s)
    Else
        FetchNumber = Val(s)
    End If
End Function
Private Sub FileExit_Click()
    If (OkToExit()) Then
        End
    End If
End Sub
Private Sub FileNew_Click()
    Dim wRtn As Integer
    Dim ts As Variant
    If (fModified) Then
        wRtn = MsgBox("Discard changes to current file?", 36)
        If (wRtn <> 6) Then
            Exit Sub
        End If
    End If
    MIDIFile1.filename = "Untitled.mid"
    Form1.Caption = "Untitled.mid"
    On Error Resume Next
    ts = FileDateTime("Untitled.mid")
    wRtn = Err
    On Error GoTo 0
    If (wRtn = 0) Then
        wRtn = MsgBox("Untitled.mid already exists, do you want to recreate it?", 36)
        If (wRtn = 6) Then
            Kill "Untitled.mid"
            wRtn = 1
        Else
            wRtn = 0
        End If
    Else
        wRtn = 1
    End If
    If (wRtn) Then
        MIDIFile1.Action = MIDIFILE_CREATE
        MIDIFile1.Action = MIDIFILE_SAVE
    Else
        MIDIFile1.Action = MIDIFILE_OPEN
    End If
    DisplayTrackList
    TrackList.ListIndex = 0
    fModified = 0
End Sub
Private Sub FileOpen_Click()
    On Error Resume Next
    CMDialog1.DialogTitle = "Open MIDI File"
    CMDialog1.Filter = "(*.mid) MIDI files|*.mid|"
    CMDialog1.DefaultExt = "mid"
    CMDialog1.FilterIndex = 0
    CMDialog1.Flags = &H1000&
    CMDialog1.Action = 1
    If (Err) Then
        Exit Sub
    End If
    DoEvents
    Screen.MousePointer = 11
    MIDIFile1.filename = CMDialog1.filename
    MIDIFile1.Action = MIDIFILE_OPEN
    DisplayTrackList
    TrackList.ListIndex = 1
    fModified = 0
    Screen.MousePointer = 0
    End Sub
Private Sub FileSave_Click()
    MIDIFile1.Action = MIDIFILE_SAVE
End Sub
Private Sub FileSaveAs_Click()
    If (SaveAs()) Then
        Form1.Caption = CMDialog1.filename
    End If
End Sub
Private Sub Form_Load()
    Dim i As Integer
    '
    ' Fill output device combo box
    '
    For i = -1 To MIDIOutput1.DeviceCount - 1
        MIDIOutput1.DeviceID = i
        OutputDevCombo.AddItem MIDIOutput1.ProductName
    Next
    '
    ' Select first in list
    '
    MIDIOutput1.DeviceID = -1
    OutputDevCombo.ListIndex = 0
    '
    ' Fill input device combo box
    '
    For i = 0 To MIDIInput1.DeviceCount - 1
        MIDIInput1.DeviceID = i
        InputDevCombo.AddItem MIDIInput1.ProductName
    Next
    '
    ' Select first in list
    '
    MIDIInput1.DeviceID = 0
    InputDevCombo.ListIndex = 0
    fModified = 0
    Form1.Show
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If (OkToExit() <> True) Then
        Cancel = True
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
    CloseOutputDevice
    CloseInputDevice
End Sub
Private Function FormatNumber(n As Long) As String
    If (HexCheck.Value) Then
        If n > 256 Then
            Beep
            End If
        FormatNumber = Hex$(n)
    Else
        FormatNumber = Format(n)
        End If
    End Function
Private Sub GetTempoChanges()
    Dim m As Integer
    Dim TempoChangeCount As Integer
    Dim CurrentTime As Long
    Screen.MousePointer = 11
    TotalTempoChanges = 0
    MIDIFile1.TrackNumber = 1
    For m = 1 To MIDIFile1.MessageCount
        MIDIFile1.MessageNumber = m

        'Meta Tempo Event
        If (MIDIFile1.Message = 255) And MIDIFile1.Data1 = &H51 Then
            'Keep track of the total number of tempo changes in this MIDI file
            TotalTempoChanges = TotalTempoChanges + 1
            'This is the tempo
            TempoSetting(TotalTempoChanges) = MIDIFile1.Tempo
            'Calculate msPerTick at this tempo -- this is used when playing back MIDI input
            msPerTick(TotalTempoChanges) = TempoSetting(TotalTempoChanges) / 1000 / MIDIFile1.TicksPerQuarterNote
            'Calculate ticksPerMs at this tempo -- this is used when recoding MIDI input
            ticksPerMs(TotalTempoChanges) = MIDIFile1.TicksPerQuarterNote / TempoSetting(TotalTempoChanges) * 1000

            TempoTime(TotalTempoChanges) = TempoTime(TotalTempoChanges - 1) + MIDIFile1.Time * msPerTick(TotalTempoChanges)
            'Display the first tempo
            LabelTempo.Caption = Int(60000000 / TempoSetting(1))
            'Display TickperQuarterNote
            LabelTicks.Caption = MIDIFile1.TicksPerQuarterNote
        End If
    Next
    Screen.MousePointer = 0
End Sub
Private Sub GetTimeSignature()
    Dim m As Integer
    MIDIFile1.TrackNumber = 1
    For m = 1 To MIDIFile1.MessageCount
        MIDIFile1.MessageNumber = m

        'Meta Event Key Signature
        If (MIDIFile1.Message = 255) And MIDIFile1.Data1 = &H58 Then
            LabelTimeSignature.Caption = MIDIFile1.Numerator & "/" & MIDIFile1.Denominator ^ 2
        End If
    Next
End Sub
Private Function GetTrackName(Track As Integer) As String
    Dim i As Integer
    MIDIFile1.TrackNumber = Track
    For i = 1 To MIDIFile1.MessageCount
        MIDIFile1.MessageNumber = i
        '
        'Meta Event
        '
        If (MIDIFile1.Message = 255) And MIDIFile1.Data1 = 3 Then
            If (MIDIFile1.MsgText = "") Then
                GetTrackName = "Track" & Str(Track) & " (null)"
            Else
                GetTrackName = MIDIFile1.MsgText
            End If
            Exit Function
        End If
    Next
    GetTrackName = "Track" & Str(Track)
End Function
Private Sub InputDevCombo_Click()
    '
    ' Stop and Close currently opened device (if any)
    '
    StopRecording
End Sub
Private Sub MessageList_Click()
    MIDIFile1.MessageNumber = MessageList.ListIndex + 1
    TimeEdit.Text = FormatNumber(CLng(MIDIFile1.Time))
    MessageEdit.Text = FormatNumber(CLng(MIDIFile1.Message))
    Data1Edit.Text = FormatNumber(CLng(MIDIFile1.Data1))
    Data2Edit.Text = FormatNumber(CLng(MIDIFile1.Data2))
    BufferEdit.Text = MIDIFile1.Buffer
    MsgTextEdit.Text = MIDIFile1.MsgText
End Sub
Private Sub MIDIInput1_Message()
    Dim InMessage As Integer
    Dim InData1 As Integer
    Dim InData2 As Integer
    Dim Y As Integer
    If (fGotFirst = False) Then
        InPreviousTime = MIDIInput1.Time
        fGotFirst = True
        fRecording = True
    End If
    '
    'This do while loop allows you to take all the messages that are
    'waiting in the message queue.
    '
    Do While MIDIInput1.MessageCount > 0
        '
        'This is the incoming MIDI data
        '
        InMessage = MIDIInput1.Message
        InData1 = MIDIInput1.Data1
        InData2 = MIDIInput1.Data2
        '
        ' Copy input to output?
        '
        If (MidiThruCheck.Value) Then
            '
            'Tell MIDIOutput1 to send the MIDI data
            '
            MIDIOutput1.Message = InMessage
            MIDIOutput1.Data1 = InData1
            MIDIOutput1.Data2 = InData2
            MIDIOutput1.Action = MIDIOUT_SEND
        End If
        If (InsertRecordingCheck.Value) And InMessage < 254 Then

            ' Copy message parameters
            MIDIFile1.Message = InMessage
            MIDIFile1.Data1 = InData1
            MIDIFile1.Data2 = InData2

            ' Calculate time in ticks
            InCurrentTime = MIDIInput1.Time
            MIDIFile1.Time = (InCurrentTime - InPreviousTime) * msPerTick(1)
            InPreviousTime = InCurrentTime
            ' insert message into MIDI file
            MIDIFile1.Action = MIDIFILE_INSERT_MESSAGE
        End If
        '
        'Remove the MIDI data from the MIDI IN queue
        '
        MIDIInput1.Action = MIDIIN_REMOVE
    Loop
End Sub
Private Sub MIDIOutput1_Error(ErrorCode As Integer, ErrorMessage As String)
   If (ErrorCode <> 0) And (ErrorCode <> 8) Then
      MsgBox ErrorMessage
      End If
End Sub
Private Sub MIDIOutput1_MessageSent(MessageTag As Long)
    LabelTempo.Caption = Str$(Int(60000000 / TempoSetting(MessageTag)))
End Sub
Private Sub MIDIOutput1_QueueEmpty()
    StopPlay
End Sub
Private Function OkToExit() As Integer
    Dim wRtn As Integer
    If (fModified) Then
        wRtn = MsgBox("Save file before exiting?", 36)
        If (wRtn = 6) Then
            If (MIDIFile1.filename = "Untitled.mid") Then
                If (SaveAs() = False) Then
                   OkToExit = False
                   Exit Function
                End If
            Else
                MIDIFile1.Action = MIDIFILE_SAVE
            End If
        End If
    End If
    OkToExit = True
End Function
Private Sub OpenInputDevice()
    MIDIInput1.DeviceID = InputDevCombo.ListIndex
    MIDIInput1.Action = MIDIIN_OPEN
End Sub
Private Sub OpenOutputDevice()
    '
    ' Restore defaults
    '
    PlaybackRateSlider = 0
    '
    ' Open selected device
    '
    MIDIOutput1.DeviceID = OutputDevCombo.ListIndex - 1
    MIDIOutput1.Action = MIDIOUT_OPEN
End Sub
Private Sub OutputDevCombo_Click()
    '
    ' Stop and Close currently opened device (if any)
    '
    StopPlay
End Sub
Private Sub QueueTrack(Track As Integer)
    Dim m As Integer
    Dim n As Integer
    Dim i As Double
    Dim TempoChangeCount As Integer
    Dim msTickTime As Integer
    Dim TimerTagCount As Integer
    PreviousTime = 0
    CurrentTime = 0
    TimerTagCount = 0
    TempoChangeCount = 1
    MIDIFile1.TrackNumber = Track
    For m = 1 To MIDIFile1.MessageCount
        MIDIFile1.MessageNumber = m

        'Meta Event
        If (MIDIFile1.Message <> 255) Then
            'PreviousTime is = to the total ms into the song for this track
            '
            'Int(MIDIFile1.Time * msPerTick(TempoChangeCount)) is = to the total ms
            'that need to pass before playing the next event
            '
            CurrentTime = PreviousTime + MIDIFile1.Time * msPerTick(TempoChangeCount)
            'if the time value of TempoTime(TempoChangeCount) is less than or equal
            'to the current time, a tempo change is needed.
            '
            'Note that msPerTick() is set in Sub GetTempoChanges () at the time a new MIDI
            'file is loaded.
            If TotalTempoChanges > TempoChangeCount And TempoTime(TempoChangeCount) <= CurrentTime Then
                'Use MessageTag property in MIDIOutput1 fire an event at the time the
                'tempo changes so that we can change the LabelTempo.Caption.
                '
                'See: Sub MIDIOutput1_MessageSent for actual updating of LabelTempo.Caption
                MIDIOutput1.MessageTag = TempoChangeCount
                TempoChangeCount = TempoChangeCount + 1
            End If

            'Time in ms to send this event
            MIDIOutput1.Time = CurrentTime
            'Keep track of the CurrentTime for the next event we queue
            PreviousTime = CurrentTime

            ' Put message data in control
            MIDIOutput1.Message = MIDIFile1.Message
            MIDIOutput1.Data1 = MIDIFile1.Data1
            MIDIOutput1.Data2 = MIDIFile1.Data2

            ' Add to output queue
            MIDIOutput1.Action = MIDIOUT_QUEUE
        End If
    DoEvents
    Next
End Sub
Private Function SaveAs() As Integer
    CMDialog1.DialogTitle = "Save MIDI File As"
    On Error Resume Next
    CMDialog1.Flags = &H2&
    CMDialog1.Action = 2
    If (Err) Then
        SaveAs = False
        Exit Function
    End If
    On Error GoTo 0
    MIDIFile1.filename = CMDialog1.filename
    MIDIFile1.Action = MIDIFILE_SAVE_AS
    SaveAs = True
End Function
Private Sub StartPlay()
    OpenOutputDevice
    MIDIOutput1.Action = MIDIOUT_START
    CmdPlay.Enabled = False
    CmdRecord.Enabled = False
    CmdStop.Enabled = True
End Sub
Private Sub StartRecording()
    OpenInputDevice
    MIDIInput1.Action = MIDIIN_START
    'InPreviousTime = MIDIInput1.Time
    CmdPlay.Enabled = False
    CmdRecord.Enabled = False
    CmdStop.Enabled = True
    fGotFirst = False
End Sub
Private Sub StopPlay()
    MIDIOutput1.Action = MIDIOUT_STOP
    CloseOutputDevice
    CmdPlay.Enabled = True
    CmdRecord.Enabled = True
    CmdStop.Enabled = False
End Sub
Private Sub StopRecording()
    MIDIInput1.Action = MIDIIN_STOP
    CloseInputDevice
    If (MidiThruCheck) Then
        CloseOutputDevice
    End If
    CmdPlay.Enabled = True
    CmdRecord.Enabled = True
    CmdStop.Enabled = False
    fRecording = False
    If (InsertRecordingCheck) Then
        DisplayTrack (TrackList.ListIndex + 1)
    End If
End Sub
Private Sub PlaybackRateSlider_Change()
    MIDIOutput1.PlaybackRate = PlaybackRateSlider.Value
End Sub
Private Sub TrackList_Click()
    DisplayTrack (TrackList.ListIndex + 1)
End Sub